home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / procobj.scm < prev    next >
Text File  |  1995-10-25  |  11KB  |  296 lines
  1. ;;; Unix wait & process objects for scsh
  2. ;;; Copyright (c) 1993, 1994, 1995 by Olin Shivers.
  3.  
  4. ;;; This is a GC'd abstraction for Unix process id's.
  5. ;;; The problem with Unix pids is (a) they clutter up the kernel
  6. ;;; process table until you wait(2) them, and (b) you can only
  7. ;;; wait(2) them once. Scsh's process objects are similar, but
  8. ;;; allow the storage to be allocated in the scsh address space,
  9. ;;; and out of the kernel process table, and they can be waited on
  10. ;;; multiple times.
  11.  
  12. ;;; Process objects
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. (define-record proc        ; A process object
  16.   pid        ; Proc's pid.
  17.   (%status #f)    ; The cached exit status of the process; 
  18.                 ; #f if we haven't wait(2)'d the process yet.
  19.  
  20.   ;; Make proc objects print like #{proc 2318}.
  21.   ((disclose p) (list "proc" (proc:pid p))))
  22.  
  23.  
  24. ;;; Indexing this table by pid requires a linear scan. 
  25. ;;; Probably not an important op, tho.
  26.  
  27. (define process-table (make-population))
  28.  
  29. (define (maybe-pid->proc pid)
  30.   (call/cc (lambda (quit)
  31.          ;; Search the table.
  32.          (walk-population (lambda (p)
  33.                 (if (= (proc:pid p) pid) (quit p)))
  34.                   process-table)
  35.          #f)))
  36.  
  37. (define (pid->proc pid . maybe-probe?)
  38.   (let ((probe? (optional-arg maybe-probe? #f)))
  39.     (or (maybe-pid->proc pid)
  40.     (case probe?
  41.       ((#f)     (error "Pid has no corresponding process object" pid))
  42.       ((create) (let ((p (make-proc pid)))     ; Install a new one.
  43.               (add-to-population! p  process-table)
  44.               p))
  45.       (else     #f)))))
  46.          
  47. ;;; Coerce pids and procs to procs.
  48.  
  49. (define (->proc proc/pid)
  50.   (cond ((proc? proc/pid) proc/pid)
  51.     ((and (integer? proc/pid) (>= proc/pid 0))
  52.      (pid->proc proc/pid))
  53.     (else (error "Illegal parameter" ->proc proc/pid))))
  54.  
  55.  
  56. ;;; Is X a pid or a proc?
  57.  
  58. (define (pid/proc? x) (or (proc? x) (and (integer? x) (>= pid 0))))
  59.  
  60.  
  61. ;;; Process reaping
  62. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63. ;;; "Reaping" a process means using wait(2) to move its exit status from the
  64. ;;; kernel's process table into scsh, thus cleaning up the kernel's process
  65. ;;; table and saving the value in a gc'd data structure, where it can be
  66. ;;; referenced multiple times.
  67. ;;;
  68. ;;; - Stopped processes are never reaped, only dead ones.
  69. ;;; 
  70. ;;; - Stopped process status codes are never cached in proc objects, 
  71. ;;;   only status codes for dead processes. So you can wait for a
  72. ;;;   dead process multiple times, but only once per process-stop.
  73. ;;; 
  74. ;;; - Unfortunately, reaping a process loses the information specifying its
  75. ;;;   process group, so if a process is reaped into scsh, it cannot be
  76. ;;;   waited for by WAIT-PROCESS-GROUP. Notice that only dead processes are
  77. ;;;   reaped, not suspended ones. Programs almost never use WAIT-PROCESS-GROUP
  78. ;;;   to wait for dead processes, so this is not likely to be a problem. If
  79. ;;;   it is, turn autoreaping off with (autoreap-policy #f).
  80. ;;; 
  81. ;;; - Reaping can be encouraged by calling (REAP-ZOMBIES).
  82.  
  83. ;;; (autoreap-policy [new-policy])
  84.  
  85. (define *autoreap-policy* 'early) ; Not exported from this module.
  86.  
  87. (define (autoreap-policy  maybe-policy)
  88.   (let ((old-policy *autoreap-policy*))
  89.     (if (pair? maybe-policy)
  90.     (let ((new-policy (car maybe-policy)))
  91.       (cond ((pair? (cdr maybe-policy))
  92.          (error "Too many args to autoreap-policy" maybe-policy))
  93.         ((not (memq new-policy '(early #f)))
  94.          (error "Illegal autoreap policy." new-policy))
  95.         (else (set! *autoreap-policy* new-policy)))))
  96.     old-policy))
  97.  
  98.  
  99. ;;; (reap-zombies)  => bool
  100. ;;;   Move any zombies from the kernel process table into scsh.
  101. ;;;   Return true if no more outstanding children; #f if some still live.
  102.  
  103. (define (reap-zombies)
  104.   (let lp ()
  105.     (receive (pid status) (%wait-any wait/poll)
  106.       (if pid
  107.       (begin (add-reaped-proc! pid status)
  108.          (lp))
  109.       status))))
  110.  
  111. ;;; This list contains procs that haven't exited yet. FORK adds new
  112. ;;; procs to the list. When a proc exits, it is removed from the list.
  113. ;;; Being on this list keeps live children's proc objects from being gc'd.
  114.  
  115. (define unexited-procs '())
  116.  
  117. (define (new-child-proc pid)
  118.   (let ((proc (make-proc pid)))
  119.     (add-to-population! proc process-table)
  120.     (set! unexited-procs (cons proc unexited-procs))
  121.     proc))
  122.  
  123. (define (mark-proc-exited proc)
  124.   (set! unexited-procs (del proc unexited-procs)))
  125.  
  126.  
  127. ;;; (WAIT proc/pid [flags])
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129.  
  130. ;;; (wait proc/pid [flags]) => status or #f
  131. ;;;
  132. ;;; FLAGS (default 0) is the exclusive or of the following:
  133. ;;;     wait/poll    
  134. ;;;        Return #f immediately if there are no 
  135. ;;;        unwaited children available. 
  136. ;;;     wait/stopped-children
  137. ;;;         Report on suspended children as well.
  138. ;;;
  139. ;;;     If the process hasn't terminated (or suspended, if wait/stopped 
  140. ;;;     is set) and wait/poll is set, return #f.
  141.  
  142. ;;; WAIT waits for a specific process. Currently, if the autoreap policy is
  143. ;;; 'early, it also does a (reap-zombies) Before performing a waitpid(2)
  144. ;;; systcall, wait first consults the proc object to see if a/the process has
  145. ;;; been reaped already. If so, its saved status is returned immediately.
  146. ;;;
  147.  
  148. ;;; (wait-any [flags]) => [proc status]
  149. ;;;     [#f #f] => non-blocking, none ready.
  150. ;;;     [#f #t] => no more.
  151.  
  152. ;;; (wait-process-group [pid/proc flags]) => [proc status]
  153. ;;;     [#f #f] => non-blocking, none ready.
  154. ;;;     [#f #t] => no more.
  155.  
  156. (define (wait pid/proc . maybe-flags)
  157.   (if (not *autoreap-policy*) (reap-zombies))
  158.   (let ((flags (check-arg integer? (optional-arg maybe-flags 0) wait))
  159.     (proc (->proc pid/proc)))
  160.     (cond ((proc:%status proc) =>    ; Already reaped.
  161.        (lambda (status)
  162.          (mark-proc-waited! proc)    ; Not eligible for a WAIT-ANY.
  163.          status))
  164.       (else                ; Really wait.
  165.        (cache-wait-status proc (%wait-pid (proc:pid proc)
  166.                           flags))))))
  167.  
  168. (define (cache-wait-status proc status)
  169.   (cond ((and (integer? status)
  170.           (not (status:stop-sig status)))    ; He's dead, Jim.
  171.      (set-proc:%status proc status)    ; Cache exit status.
  172.      (mark-proc-exited proc)))    ; We're now gc'able.
  173.   status)
  174.  
  175.  
  176. ;;; (wait-any [flags]) -> [proc status]
  177.  
  178. (define (wait-any . maybe-flags)
  179.   (let ((flags (check-arg integer? (optional-arg maybe-flags 0) wait-any)))
  180.     (if (not *autoreap-policy*) (reap-zombies))
  181.     (cond ((get-reaped-proc!) =>            ; Check internal table.
  182.        (lambda (proc) (values proc (proc:%status proc))))    ; Hit.
  183.       (else
  184.        (receive (pid status) (%wait-any flags) ; Really wait.
  185.          (if pid
  186.          (let ((proc (pid->proc pid)))
  187.            (cache-wait-status proc status)
  188.            (values proc status))
  189.          (values pid status)))))))    ; pid = #f -- Empty poll.
  190.  
  191.  
  192. ;;; (wait-process-group [proc-group flags])
  193. ;;; 
  194. ;;; If you are doing process-group waits, you do *not* want to use 
  195. ;;; early autoreaping, since the reaper loses process-group information.
  196.  
  197. (define (wait-process-group . args)
  198.   (receive (proc-group flags) (parse-optionals args 0 0)
  199.     (check-arg integer? flags wait-process-group)
  200.     (if (not *autoreap-policy*) (reap-zombies))
  201.     (let ((proc-group (cond ((integer? proc-group) proc-group)
  202.                  ((proc? proc-group)    (proc:pid proc-group))
  203.                  (else (error "Illegal argument" wait-process-group
  204.                       proc-group)))))
  205.       (receive (pid status) (%wait-process-group proc-group flags)
  206.     (if pid
  207.         (let ((proc (pid->proc pid)))
  208.           (cache-wait-status proc status)
  209.           (values proc status))
  210.         (values pid status))))))        ; pid = #f -- Empty poll.
  211.  
  212.  
  213.  
  214. ;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags)
  215. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  216. ;;; Direct interfaces to waitpid(2) call.
  217. ;;; [#f #f] means no processes ready on a non-blocking wait.
  218. ;;; [#f #t] means no waitable process on wait-any.
  219.  
  220. (define (%wait-pid pid flags)
  221.   (let lp ()
  222.     (receive (err pid status) (%wait-pid/errno pid flags)
  223.       (if err
  224.       (if (= err errno/intr) (lp)
  225.           (errno-error err %wait-pid pid flags))
  226.       (and (not (zero? pid)) status)))))    ; pid=0 => none ready.
  227.  
  228.  
  229. (define (%wait-any flags)
  230.   (let lp ()
  231.     (receive (err pid status) (%wait-pid/errno -1 flags)
  232.       (cond (err (cond ((= err errno/child) (values #f #t))    ; No more.
  233.                ((= err errno/intr)  (lp))
  234.                (else (errno-error err %wait-any flags))))
  235.         ((zero? pid) (values #f #f))            ; None ready.
  236.         (else (values pid status))))))
  237.  
  238. (define (%wait-process-group pgrp flags)
  239.   (let lp ()
  240.     (receive (err pid status) (%wait-pid/errno (- pgrp) flags)
  241.       (cond (err (cond ((= err errno/child) (values #f #t))    ; No more.
  242.                ((= err errno/intr) (lp))
  243.                (else (errno-error err %wait-process-group pgrp flags))))
  244.         ((zero? pid) (values #f #f))            ; None ready.
  245.         (else (values pid status))))))
  246.  
  247.  
  248. ;;; Reaped process table
  249. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  250. ;;; We keep track of procs that have been reaped but not yet waited on by
  251. ;;; the user's code. These proces are eligible for return by WAIT-ANY.
  252. ;;; We keep track of these so that WAIT-ANY will hand them out exactly once.
  253. ;;; Whenever WAIT, WAIT-ANY, WAIT-PROCESS-GROUP waits on a process to exit,
  254. ;;; it removes the process from this table if it's in it.
  255. ;;; This code is bogus -- we use weak pointers. We need populations that
  256. ;;; support deletion or filtering.
  257.  
  258. (define reaped-procs '())    ; Reaped, but not yet waited. 
  259.  
  260. (define (filter-weak-ptr-list pred lis)
  261.   (reverse (reduce (lambda (wptr result)
  262.              (let ((val (weak-pointer-ref wptr)))
  263.                (if (and val (pred val))
  264.                    (cons wptr result)
  265.                    result)))
  266.            '()
  267.            lis)))
  268.  
  269. ;;; Add a newly-reaped proc to the list.
  270. (define (add-reaped-proc! pid status)
  271.   (cond ((maybe-pid->proc pid) =>
  272.          (lambda (proc)
  273.        (set-proc:%status proc status)
  274.        (set! reaped-procs (cons (make-weak-pointer proc)
  275.                     reaped-procs))))
  276.     (else (error "Child pid mysteriously missing proc object." pid))))
  277.   
  278. ;;; Pop one off the list.
  279. (define (get-reaped-proc!)
  280.   (and (pair? reaped-procs)
  281.        (let ((proc (weak-pointer-ref (car reaped-procs))))
  282.      (set! reaped-procs (cdr reaped-procs))
  283.      (or proc (get-reaped-proc!)))))
  284.  
  285. ;;; PROC no longer eligible to be in the list. Delete it.
  286. (define (mark-proc-waited! proc)
  287.   (set! reaped-procs (filter-weak-ptr-list (lambda (elt) (not (eq? proc elt)))
  288.                        reaped-procs)))
  289.  
  290. ;;; The mark-proc-waited! machinery above is a crock. It is inefficient --
  291. ;;; we should have a flag in the proc saying if it's eligible for a WAIT-ANY.
  292. ;;; Starts off #t, changes to #f after a wait. On a #t->#f transition, we
  293. ;;; delete it from the WAIT-ANY population. Right now, every time the user
  294. ;;; waits on the proc, we re-delete it from the population -- which is
  295. ;;; a no-op after the first time.
  296.